perm filename HOMER.F4[P11,LCS] blob
sn#592324 filedate 1981-06-02 generic text, type T, neo UTF8
C***** HOMER, PLACE, HOMX, LULOOP, ZCRSOR, HELP, ORDER, DPYX, FILX, RREAD, NUMZ
C****** FOR 'HOMING' OF BEAMS, SLURS, AND CHORD NOTES ***********
SUBROUTINE HOMER
COMMON /STF/RSTFAC(8),RSTJ2
COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20) /POSI/STFF(8),JJ2,POS
COMMON /XRN/RN(1) /PTR/PWDS(2) /LIMIT/LIM,ITEM,L,I,IX
1 /RMOD/RMODE2,RSET4,IBEAM,NOSET,STEM,STUP,NTC,ENDP,RAD,RDD
COMMON/ALF/QQ(3),K,RA,RB,N,RG,M,X,RE,RF,A,B,DISX,INP(58)
EQUIVALENCE (R3,RJQ(1)),(R6,RJQ(4)),(J11,JQ(9))
1,(R7,RJQ(5)),(R9,RJQ(7)),(R11,RJQ(9)),(R13,RJQ(11))
1,(J10,JQ(8)),(R8,RJQ(6)),(J7,JQ(5))
IF(JA.EQ.6)GO TO 9
IF(R13.NE.0)GO TO 10
C FOR GENL HOMING; WORDS; BEAMS; (STEMS HOMING IN HOMX.F4)
C 2.44 = WIDTH OF NOTE -- NEEDED BECAUSE OF DIFF. STEM DIRECTIONS.
CALL HOMX
RETURN
9 IF(J11.LT.0)RETURN
C IF P11=-1 NO HOMING
JX=IABS(J7)/10
C JX= STEM DIR. OF BEAM
10 IF(R11.EQ.0)R11=2.9
IZ=0
CC110 RC=0
CC IF(JA.EQ.5)RC=-1.
DO 361 K=1,ITEM
IF(FINDIT(K).LT.0)GO TO 361
C SKIPS NOTES ON WRONG LINE
RDD=RN(L+3)
C L IS IN COMMON
A=RDD
JK=RN(L+5)
JK=JK/10
C /10=NOTE'S STEM DIRECTION
IF(JA.NE.6)GO TO 177
IF(JK.EQ.0)GO TO 361
IF(JK.EQ.JX)GO TO 377
C ARE STEM DIR,S SAME? YES, JUMP
IF(RN(L).LT.8.)GO TO 2377
IF(RN(L+10).NE.0)GO TO 1377
2377 A=(R4+R5)/2.
A=A-RN(L+4)
C AVERAGE HEIGHT OF BEAM LESS HEIGHT OF NOTE
IF(JK.NE.1)A=-A
C IF NOTE STEM DOWN, REVERSE SIGN
IF(A.LE.8.)GO TO 377
C IF DIFF. IS LESS THAN 8 DON'T HOOK BEAM TO STEM.
1377 B=2.44*RSTJ2
C DISX IS NOTE WIDTH( CURRENTLY =2.44)
NN=IABS(J4)
IF(NN.GE.80.AND.NN.LT.180)A=A*.6
C IS IT A MINI?
IF(JK.NE.1)B=-B
C JK+=STEM UP, -=DOWN
RDD=RDD+B
C ADD OR SUB. NOTE WIDTH FROM NOTE POS.
GO TO 177
377 IF(JK.NE.JX)GO TO 361
177 IF(PLACE(R3).GT.0)GO TO 1461
C DO NEXT IF HOMING SLUR
IF(JA.NE.5)GO TO 461
C ALSO CHECK FOR P6 (RT. END OF SLUR)
IF(PLACE(R6).LT.0)GO TO 461
JT=3
NX=4
C POINT TO R6 OR R5
GO TO 2
1461 NX=1
JT=2
C POINT TO R3 OR R4
IZ=-1
2 IF(RN(L+6).LT.10.)GO TO 1
CC IF(JK.EQ.0)GO TO 1
D=2.44
IF(RN(L+6).GE.20.)D=-D
CC IF(JK.LT.0)D=-D
E=ABS(RN(L+4))
C DIDN'T WE DO THIS BEFORE??
IF(E.GE.80.0.AND.E.LT.180.)D=D*.6*RSTFAC(J2)
RDD=RDD+D
1 IF(IZ.GT.0)GO TO 88
3 RJQ(NX)=RDD
IF(R13.GE.0)GO TO 11
CC JT=1
RIS=RN(L+4)
IF(R13.NE.-1.)GO TO 12
A0=2.
IF(R7.LT.0)A0=-A0
A0=A0+RIS
GO TO 80
12 RIZ=RN(L+8)
IF(RIZ.EQ.999.)RIZ=0
RIZ=RIZ+8.
NX=RN(L+7)
A0=MOD(NX,10)
IF(A0.NE.0)A0=(A0-1.)*1.8
C *SPACE FOR EACH TAIL.
13 A0=A0+RIZ
IF(JK.GE.2)A0=-A0
C JK =2 =STEMS DOWN
A0=A0+RIS
C JT CAN BE 2(R4) OR 3(R5)
80 RJQ(JT)=A0
11 IF(JA.EQ.6)GO TO 861
IF(JA.EQ.5)GO TO 361
RETURN
461 IF(JA.EQ.6)GO TO 277
IF(JA.NE.5)GO TO 361
C JUMP IF NOT SLUR
277 IF(PLACE(R6).LT.0)GO TO 561
CC R6=RDD
C ???????
IZ=4
C TO PUT RDD INTO R6 LATER
GO TO 2
861 IF(J7.GE.0)GO TO 361
IF(R9.LE.0)GO TO 661
561 IF(PLACE(R9).LT.0)GO TO 661
IF(J7.LT.0)GO TO 761
C J7=NEG MEANS TREMOLO
IF(R8.NE.0)GO TO 761
IF(R10.EQ.0)GO TO 361
761 IZ=7
C TO PUT RDD INTO R9 LATER
GO TO 2
C R8=0, R10=0 MEANS R9 IS NUMBER OUTSIDE OF BEAM.
661 IF(JA.EQ.5)GO TO 361
IF(J10.EQ.0)GO TO 361
IF(PLACE(R8).LT.0)GO TO 361
C HOMES INNER PARTIAL BEAMS
IZ=6
C TO PUT RDD INTO R8 LATER
GO TO 2
88 RJQ(IZ)=RDD
C PUT A INTO RIGHT PARAM.
361 CONTINUE
END
FUNCTION PLACE(X)
COMMON R2,JA,CENTR,J2,RJQ(8),R11
1 /RMOD/RMODE2,RSET4,IBEAM,NOSET,STEM,STUP,NTC,ENDP,RAD,RDD
PLACE=R11-ABS(RDD-X)
END
C****** FOR 'HOMING' OF BEAMS AND CHORD NOTES ***********
SUBROUTINE HOMX
COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20) /RNW/RNW
1 /POSI/STFF(0/7),JJ2,POS /LIMIT/LIMIT,ITEM,L,I,IX
2 /STF/RSTFAC(0/7),RSTJ2 /XRN/RN(1) /PTR/PWDS(1)
3 /ALF/QQ(3),K,RA,RB,N,RG,M,X,RE,RF,A,B,DISX,INP(58)
4 /OLDTOP/OLDY
EQUIVALENCE (R3,RJQ(1)),(R7,RJQ(5)),(R9,RJQ(7))
1,(R4,RJQ(2)),(R8,RJQ(6)),(R5,RJQ(3)),(R10,RJQ(8))
JJ2=1000
C THE STAFF # =R2
DO 110 K=1,ITEM
IF(CODN(K,L).NE.6)GO TO 110
C RETURNS POINTER IN L
C%%%%%%%%%%%
IF(R2.GT.7)GO TO 10
C J2=STAFF #. >7 = ALL STAVES.
IF(RN(L+2).NE.R2)GO TO 110
10 R7=RN(L+7)
IF(R7)GO TO 110
C SKIP TREMOLO AND UNATTACHED PARTIAL BEAMS.
RS=RN(L+2)
C STAFF OF THIS BEAM
ISD=IFIX(R7/10.)
C STEM DIRECTION. 1=UP 2=DOWN
RM=RSTFAC(IFIX(RS))
RSTJ2=RM
C SIZE FACTOR
RL=RN(L+3)
RR=RN(L+6)
C OVERALL LEFT-RIGHT LIMITS
PL=RL
PR=RR
C LEFT-RIGHT POS. TO BE USED
RLH=RN(L+4)
RRH=RN(L+5)
C LEFT-RIGHT HEIGHTS
RMIN=1.
MIN=-1
C FLAG FOR MINI-NOTES AND BEAMS
W=ABS(RLH)
IF(W.LE.80)GO TO 20
CCC IF(W.GE.180)GO TO 3
C SKIP IF X NOTES, DIAMONDS, NO NOTE HEAD
MIN=0
RMIN=.6
RM=RM*.6
C MINI SIZE FACTOR
RLH=ABS(RLH)-100.
20 WC=RN(L)
C WORD COUNT
T=-1
IF(RN(L+10).GE.100)GO TO 30
C P10=100 ETC. =COMPOSITE BEAM WITH AT LEAST 1 COMPLETE ONE.
IF(WC.LT.6)GO TO 30
R8=RN(L+8)
IF(R8.EQ.0)GO TO 30
IF(R8)GO TO 110
IF(WC.LT.7)GO TO 30
R9=RN(L+9)
IF(R9.EQ.0)GO TO 30
PL=R8
PR=R9
C POS. OF INNER PARTIAL BEAM.
IF(WC.LT.8)GO TO 30
IF(RN(L+10).GT.0)T=RN(L+10)+T
30 IR7=AMOD(R7,10.0)+T
C NUMBER OF BEAMS
PL=PL-.1
PR=PR+.1
C FOR ROUND-OFF ERROR
T=RR-RL
C TOTAL LENGTH OF FULL BEAM
TH=RRH-RLH
C TOTAL HEIGHT
T=TH/T
C FACTOR
DO 100 J=1,ITEM
IF(CODN(J,L).NE.1)GO TO 100
IF(RN(L+2).NE.RS)GO TO 100
C SKIP IF NOT ON RIGHT STAFF
R5=RN(L+5)
IF(R5.LT.10)GO TO 100
C SKIP IF NO STEM ON NOTE
R3=RN(L+3)
IXD=0
CW A=0
IF(IFIX(R5/10.).EQ.ISD)GO TO 40
C A IS FOR HORZ. DISPLACEMENT DUE TO OPPOSITE STEM DIRECTIONS.
IXD=-1
A=RNW*RM
C A=WIDTH OF NOTE*SIZE FACTOR + OR - RNW=WIDTH OF A NOTE(2.44)
IF(ISD.EQ.1)A=-A
R3=A+R3
40 IF(R3.LT.PL)GO TO 100
IF(R3.GT.PR)GO TO 100
C SKIP IF NOT IN BOUNDS OF BEAM SEGMENT.
CW R3=A+R3
R4=RN(L+4)
R4X=ABS(R4)
R4=AMOD(R4,100.0)
IF(R4X.LE.80)GO TO 50
IF(R4X.GE.180)GO TO 50
IF(MIN)GO TO 100
C NOW MINI-NOTE
CC R4=ABS(R4)-100.
IF(R4.GT.80.)R4=R4-100.
C MINIS MAY GO FROM 81 TO 179. NUMS < 100 ARE CONVERTED TO NUM-100.
GO TO 60
50 IF(MIN.EQ.0)GO TO 100
CC R4=AMOD(R4,100.0)
CATCH DIAMONDS, X NOTES, HEADLESS NOTES.
60 R6=T*(R3-RL)
R8=RLH+R6-R4
C ADJUSTED STEM LENGTH
IF(ISD.EQ.2)R8=-R8
IF(IXD.EQ.0)GO TO 70
R9=(IR7*1.571429-13.714)*RMIN
R8=-R8
70 IF(RN(L).LT.8)GO TO 90
CHECK P10 FOR STAFF CHANGE FLAG
R10=RN(L+10)
IF(R10.LE.0)GO TO 90
N=-1
IF(R10.EQ.2)N=-N
C N =-1 = ON STAFF BELOW, =1 = ABOVE.
M=RS
R3=ABS((STFF(M+N)-STFF(M))/(RSTJ2*7))
IF(IXD)GO TO 80
IF(R10.NE.ISD)R3=-R3
C ABOVE FOR STEMS SAME DIR, STAFF CHNG IN SAME DIR.
80 R8=R8+R3
C ADDS DISTANCE TO OTHER STAFF - CONVERTED TO NOTE NUMBERS.
90 IF(IXD)R8=R8+R9
C IF OPPOSITE STEM DIR., SUBTRACT (2*STEM AND EXTRA BEAM SPACE)*SIZE
IF(R8.LT.-5)GO TO 100
C AFTER ALL THAT, IF BEAM IS TOO SMALL THEN IGNORE IT.
IF(JJ2.GT.J)JJ2=J
C POINT TO 1ST ITEM TO RE-DISPLAY
RN(L+8)=R8
R7=RN(L+7)
C NEXT DELETES TAILS
IF(R7.EQ.0)GO TO 100
N=AMOD(R7,10.)
RN(L+7)=R7-N
100 CONTINUE
110 CONTINUE
IF(JJ2.EQ.1000)JJ2=-1
END
SUBROUTINE SHRINK(JIT)
COMMON /XRN/RN(1) /PTR/KWDS(1) /LIMIT/LIMIT,ITEM,L,I,IX
1 /ALF/A,B,C,K,M,N,MM
IF(JIT.EQ.0)JIT=1
MM=I
DO 40 K=ITEM,JIT,-1
L=KWDS(K)
M=RN(L)
IF(M.LE.2)GO TO 40
J=M+2+L
IF(RN(L+1).NE.1)GO TO 10
IF(RN(L+8).EQ.0)RN(L+8)=999
C NOTES MUST HAVE AT LEAST 8 PARAMS.
10 DO 20 N=J,L,-1
20 IF(RN(N).NE.0)GO TO 30
GO TO 40
30 IF(N.EQ.J)GO TO 40
M=I-N
CALL RLOOP(RN(N+1),RN(J+1),M)
MM=J-N
RN(L)=RN(L)-MM
C RESET THE WDCNT.
I=I-MM
40 CONTINUE
L=KWDS(JIT)
50 JIT=JIT+1
L=RN(L)+3+L
C POINTER TO NEXT ITEM
KWDS(JIT)=L
IF(JIT.LE.ITEM)GO TO 50
END
SUBROUTINE LULOOP
COMMON /ALF/ INP(1)
ICOM=0
DO 10 K=1,72
IF(ICOM.LT.0)INP(K)=' '
J=INP(K)
IF(J.NE.'<')GO TO 1
INP(K)=' '
ICOM=-1
GO TO 10
C USE '<' FOR COMMENTS. IGNORES REST OF LINE.
1 IF(J.EQ.' ')GO TO 10
INP(K)=J.AND..NOT.((J/2).AND."201004020100)
10 CONTINUE
END
SUBROUTINE ZCRSOR
COMMON R2,JA,CENTR,J2,R3,R4,J,K,L,M
DATA X/0.12/,Y/0.13/,Z/0.06/
CC DATA X/1.2/,Y/1.3/
CALL SETCUR(0,-300,0)
IF(R2.NE.0)GO TO 20
CC IF(R2.LT.99)GO TO 2
CALL TYPSTR('<CR> SETS LOWER-LEFT POINT')
ACCEPT 30,L
CALL RDCUR(JA,J2)
CALL TYPSTR('<CR> SETS UPPER-RIGHT POINT')
ACCEPT 30,L
CALL RDCUR(J,K)
L=J-JA
M=K-J2
IF(L.GE.M)GO TO 10
C ADD AND SUBTR. X COORDS. (MAKE THEM SAME DIST. AS Y'S)
M=(M-L)/2
J=J+M
JA=JA-M
10 L=J-JA
R2=950.0/L
JA=JA+L/2
J2=J2+(K-J2)/2
GO TO 40
20 CALL TYPSTR('<CR> SETS CENTER')
ACCEPT 30,L
30 FORMAT(I)
CALL RDCUR(JA,J2)
40 CALL CLRCUR
R3=JA*X+50.0
R4=J2*Y+52.0
K=0
C (K IS R6) ↑↑↑↑↑ SO NUMS ON SPACING SCALE WILL PRINT.
END
SUBROUTINE HELP(K)
IMPLICIT INTEGER(A-Z)
DIMENSION CDNUM(9)
COMMON /DL/X22 /RRJJ/R(21),JJA /JCHAR/A,B,IBLA /RINP/I(16,8)
1 /NUM/NUM(1)
DATA CDNUM/'10','11','12','13','14','15','16','17','18'/
L=-2
C -2=DO LOOKUP ON MSS,MUS (HELP FILES 1→18.DMD)
IF(K.NE.IBLA)GO TO 10
IF(X22.EQ.0)RETURN
C USE CURRENT CODE NUMBER IF IN EDIT MODE
K=NUM(JJA+1)
IF(JJA.GT.9)K=CDNUM(JJA-9)
10 CALL GETFI2(K,L)
IF(L.EQ.1)RETURN
C L=1=FILE NOT FOUND
L=-190
CALL TYPLOC(450,L)
20 CALL FASTI2(I,128)
DO 40 K=1,8
IF(I(1,K).EQ.999)GO TO 60
DO 30 J=16,1,-1
30 IF(I(J,K).NE.' ')GO TO 40
J=1
40 TYPE 50,(I(L,K),L=1,J)
GO TO 20
50 FORMAT(1X16A5/)
60 CALL TYPCRLF
END
SUBROUTINE ORDER
IMPLICIT INTEGER(A-Q,S-Z)
COMMON R2 /LIMIT/LIMIT,ITEM /ALF/I1
1 /PTR/PWDS(1) /XRN/RN(1) /DPY/RST(1) /DPTR/WDS(1)
J=1
CC J=4
C J=4 SO FRONT OF DPY BUFFER IS UNTOUCHED.
JJ=1
DO 40 K=0,7
10 M=0
RX=9999.
DO 20 L=1,ITEM
N=PWDS(L)
IF(R2.EQ.0.AND.K.NE.RN(N+2))GO TO 20
C R2.EQ.0 = ORDER BY STAVES .NE.0 =ORDER ALL LEFT TO RIGHT
R=RN(N+3)
IF(R.EQ.10000.)GO TO 20
C SKIP ITEM THAT WAS ALREADY SHUFFLED
IF(RN(N+1).EQ.16)GO TO 30
C DO NOT ORDER TEXT. (CODE 16)
IF(R.GE.RX)GO TO 20
RX=R
M=L
20 CONTINUE
IF(M.EQ.0)GO TO 40
C FOUND NO MORE ON THIS LINE
L=M
30 WDS(JJ)=J
JJ=JJ+1
C NOW PUT AWAY NEXT ITEM IN ORDER
CC DO 3 MM=PWDS(L),PWDS(L+1)-1
CC RST(J)=RN(MM)
CC3 J=J+1
MM=PWDS(L+1)-PWDS(L)
C NEXT MOVES RN INTO RST
CALL RLOOP(RST(J),RN(PWDS(L)),MM)
J=J+MM
RN(PWDS(L)+3)=10000.
C WIPE OUT THIS POSITION
GO TO 10
40 CONTINUE
CC DO 5 K=2,ITEM
C NOW FIX UP POINTER ARRAY AGAIN
CC5 PWDS(K)=WDS(K)-3
C BECAUSE JJ STARTED AT =4
CALL RLOOP(PWDS,WDS,ITEM)
C PUTS WDS INTO PWDS
CC DO 6 K=1,PWDS(ITEM+1)
C AND RN ARRAY
CC6 RN(K)=RST(K+3)
CALL RLOOP(RN,RST,PWDS(ITEM+1))
C PUT RST BACK INTO RN
C SINCE DPY BUFFER WAS WIPED OUT, NOW DO A 'Z1' TO FIX IT UP.
I1='Z'
R2=1
CALL DPYX
END
SUBROUTINE DPYX
C DOES COMPLETE DPY SETUP
COMMON /DPY/ST(1)
CALL DPYSET(1,ST,4000)
CALL HYDPOG(2)
CALL HYDPOG(1)
CC CALL TYPLOC(450,0)
CALL DPYBRT(5)
END
SUBROUTINE FILX(K)
C CHECKS TO SEE IF SOS OR ET FILE. IF SOS, REWRITES IT SANS #S.
COMMON /ALF/I(72) /JCHAR/IXX,ISEMI,IBLA /A2Z/AA,BB,LCC,
1 DD,EE,FF,GG,LHH,LII,LJJ,LKK,LEL,LMM,LNN,LOH /NUM/NZERO
CALL IFILE(1,K)
READ(1,50)I
IF(I(1).EQ.NZERO)GO TO 70
CXX **** FIX AT IRCAM 1/80 ***** IF(I(1).NE.LCC.AND.I(2).NE.LOH)GO TO 30
IF(I(1).NE.LCC.OR.I(2).NE.LOH)GO TO 30
C IF 1ST CHAR. IS ZERO, ASSUME IT'S AN SOS FILE
C ASSUMES 'COMMENT' IF 1ST 2 CHARS ARE C AND O.
20 READ(1,50)I
IF(I(3).NE.ISEMI)GO TO 20
C GET RID OF HEADER.
READ(1,50)I
C ONCE AGAIN!!
RETURN
30 READ(1,50,END=40)I
GO TO 30
C CLEAN EVERYTHING OUT.
40 CALL IFILE(1,K)
RETURN
50 FORMAT(72A1)
60 FORMAT(I,72A1)
70 K='FOR21'
CALL OFILE(21,K)
REREAD 60,L,I
CALL TYPSTR('SOS FILE COPIED TO FOR21.DAT')
CALL TYPCRLF
GO TO 90
80 READ(1,60,END=100)L,I
90 WRITE(21,50)I
GO TO 80
100 END FILE 21
GO TO 40
END
SUBROUTINE RREAD(I,V)
C TAKES ASCII INPUT (INP) STRING, SEPARATES LETTERS FROM NUMBERS.
C MAKES ALL NUMBS FLTING PT. FILLS UP END OF ARRAY WITH ZEROS.
C SENDS BACK IN V ARRAY.
C E.G. 'GET FOO 4.55' SENDS BACK V1=0, V2=0, V3=4.55, V4=0, ETC.
DIMENSION I(1),V(1)
EQUIVALENCE (N,RN)
DO 62 J=1,50
C ZERO V AND IV ARRAYS.****** 50 IS DIMENSION GIVEN IN MARKZ,BEAMS,SLURZ *********
62 V(J)=0
DO 6 LEND=71,1,-1
6 IF(I(LEND).NE.' ')GO TO 7
C LEND=END OF CHARS. STARTS WITH NEXT-TO-LAST (LAST IS *)
RETURN
9 IF(LETR.EQ.0)M=M+1
LETR=-1
GO TO 16
7 M=1
J=1
LETR=0
8 N=I(J)
CALL LO2UP(N)
IF(N.NE.' '.AND.N.NE.'/')GO TO 11
C IGNORES BLANKS AND SLASHES
LETR=0
GO TO 16
11 IF(N.EQ.'-')GO TO 16
CX IF(N.NE.'F')GO TO 1
C THIS IS FOR FINGERING NUMS. /3 F4/5 F1/ ETC.
CX NN=I(J+1)
CX IF(NN.GE.'0'.AND.NN.LE.'9')GO TO 9
C CONSIDER 'F4' ETC. AS A UNIT.
C IGNORE '-' (BUT LOOK IN NUMZ TO SEE IF JUST BEFORE A NUM.)
C IF(N.NE.'-'.AND.
C 1 N.NE.'.'.AND.(N.LT.'0'.OR.N.GT.'9'))GO TO 10
CRR*** IF( N.NE.'.'.AND.(N.LT.'0'.OR.N.GT.'9'))GO TO 10
1 IF( N.NE.'.'.AND.(N.LT.'0'.OR.N.GT.'9'))GO TO 9
C NOW IT'S A NUMBER
20 CALL NUMZ(KK,I(J),V(M))
J=J+KK-1
CXX LETR=0
C ABOVE IS NEW ON OCT. 1, 1980 *******
10 M=M+1
16 J=J+1
IF(J.LE.LEND)GO TO 8
END
SUBROUTINE NUMZ(KK,I,X)
DIMENSION I(1)
DATA IZERO/'0'/,ININE/'9'/
J=-1
M=0
XMINUS=1.
IF(I(0).EQ.'-')XMINUS=-XMINUS
C I(0) MIGHT NOT WORK WITH SOME FORTRANS!!
DO 21 KK=1,15
C IS 15 ENOUGH? YES, WILL DO ONLY 8 DIGITS PLUS DECI.PT.
IX=I(KK)
IF(IX.GE.IZERO.AND.IX.LE.ININE)GO TO 22
C IF(IX.EQ.'-')GO TO 24
IF(IX.NE.'.')GO TO 20
J=KK
GO TO 21
C 24 XMINUS=-XMINUS
C GO TO 21
22 N=(IX-IZERO)/536870912
M=N+M*10
21 CONTINUE
20 IF(J.LT.0)GO TO 23
X=KK-J-1
X=XMINUS*M/(10.**X)
RETURN
23 X=XMINUS*M
C FOR NO DECI.
END
C**IRCAM** SUBROUTINE NUMLTR(L,J)
C**IRCAM**C THIS, AND ABOVE ROUTINES, TAKE CARE OF STANFORD 'REREAD' FEATURE
C**IRCAM**C 'RREAD' IS CALLED JUST AFTER ORIGINAL READ STATEMENT
C**IRCAM** COMMON R2,JA,CEN,J2,RJQ(20) /SCM/V(22)
C**IRCAM** J=V(1)
C**IRCAM** N=L+1
C**IRCAM** R2=V(N)
C**IRCAM** DO 1 K=1,20
C**IRCAM** 1 RJQ(K)=V(K+N)
C**IRCAM** END